home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-stab.9 / f2c-stab / f2c-stabs / fts-f2si.awk < prev    next >
Encoding:
AWK Script  |  1996-02-11  |  9.6 KB  |  471 lines
  1. #!/usr/bin/awk -f
  2. # -*- awk -*-
  3. #
  4. # $Header: /usr/bfr/src/test/RCS/fts-f2si.awk,v 1.1 1995/01/18 17:39:14 abel Exp $
  5. #
  6. #********************************************
  7. #
  8. # FORTRAN to si conversion tool
  9. #
  10. #********************************************
  11. #
  12. # Written by Alexander L. Belikoff, 1994
  13. # Copyright (C)1994 Alexander L. Belikoff
  14. #
  15. # This program is free software; you can redistribute it and/or modify
  16. # it under the terms of the GNU General Public License as published by
  17. # the Free Software Foundation; either version 2 of the License, or
  18. # (at your option) any later version.
  19. #
  20. # This program is distributed in the hope that it will be useful,
  21. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  22. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23. # GNU General Public License for more details.
  24. #
  25. #********************************************
  26. #
  27. # $Log: fts-f2si.awk,v $
  28. # Revision 1.1  1995/01/18  17:39:14  abel
  29. # Initial revision
  30. #
  31. #
  32. #********************************************
  33.  
  34.  
  35. ### Global variable descriptions:
  36. ###    param_names[1..nfargs] : parameters in order.
  37. ###    param_nums             : defined by param_nums[param_names[i]] = i
  38. ###                             i.e. - inverse of param_names.
  39. ###    locals[1..nlocals]     : local variables.
  40. ###    includes[1..nincs]     : include files.
  41. ###    externals[ename]       : externals.
  42. ###    var_type[varname]      : Types of variables.
  43. ###    var_dimen[varname]     : dimensions of variables.
  44. ###    common[cname]          : common variables.
  45. ###    const_names[1..nconsts] : Names of constants (parameters)
  46. ###    const_vals[1..nconsts]  : Values of constants (parameters)
  47.  
  48. # utility to print rest of function's info
  49.  
  50. function print_arg(var) {
  51.    if (var in var_type) {
  52.       printf "\n    (%-10s %-10s %s)", var, var_type[var], var_dimen[var]
  53.    }
  54.    else {
  55.       printf "\n    (%-10s %-10s %s)", var, "%UNKNOWN%", var_dimen[var]
  56.    }
  57. }
  58.  
  59. function print_inc(inc) {
  60.    printf "\n    (%s)", inc
  61. }
  62.  
  63. function print_ext(var) {
  64.    printf "\n    (%s)", var
  65. }
  66.  
  67. function print_fcn() {
  68.  
  69. #  If there's nothing to print, just return...
  70.    if (nfargs == 0 && MODULE == "" && fcn_name == "" && nincs==0 &&
  71.        nconsts==0) {
  72.  
  73.        empty = 0
  74.        for (s in param_nums) { empty = 1 ; break }
  75.        for (s in externals)  { empty = 1 ; break }
  76.        for (s in var_type)   { empty = 1 ; break }
  77.        for (s in common)    { empty = 1 ; break }
  78.        if (empty == 1) return
  79.     }
  80.  
  81.  
  82. # output function/common block name
  83.  
  84.     if (fcn_name == "") {
  85.        printf "(*undefined*  "
  86.     }
  87.     else {
  88.        printf "(%s  ", toupper(fcn_name)
  89.     }
  90.  
  91. # output module
  92.  
  93.    if (MODULE != "")
  94.        printf "%s  ", MODULE
  95.    else
  96.        printf "*undefined*  "
  97.  
  98.  
  99. # output function type
  100.  
  101.     if (is_fn)
  102.     print toupper(fn_type)
  103.     else
  104.     print "*void*"
  105.  
  106. # parameters info
  107.  
  108.         printf ";;; Arguments:\n"
  109.     printf "  ("
  110.  
  111.     for (i = 1 ; i <= nfargs ; i++) {
  112.             print_arg(param_names[i])
  113.         }
  114.     print ")\n"
  115.  
  116. # callees
  117.  
  118.         printf ";;; Calls:\n"
  119.     printf "  ()\n"
  120.  
  121. # Local variables
  122.  
  123.     printf ";;; Local variables:\n"
  124.     printf "  ("
  125.  
  126.     for (var in var_type) {
  127.            if (! (var in param_nums)) print_arg(var)
  128.         }
  129.     print ")\n"
  130.     
  131.     
  132. # Include files
  133.     printf ";;; Includes:\n"
  134.     printf "  ("
  135.     for (i=1; i<=nincs ; i++) {
  136.            print_inc(includes[i])
  137.         }
  138.     print ")\n"
  139.  
  140. # Externals
  141.     printf ";;; Externals:\n"
  142.     printf "  ("
  143.     for (ext in externals) {
  144.            print_ext(ext)
  145.         }
  146.     print ")\n"
  147.  
  148. # Common blocks
  149.     printf ";;; Common blocks:\n"
  150.         printf "  ("
  151.     for (cb in common) {
  152.            printf "\n   (%-10s (%s))", cb, common[cb]
  153.         }
  154.     print ")\n"
  155.  
  156. # Parameters
  157.         printf ";;; Parameters:\n"
  158.         printf "  ("
  159.         for (i=1; i<=nconsts; i++) {
  160.            printf "\n   (%-10s \042%s\042)", const_names[i], const_vals[i]
  161.         }
  162.     print ")\n"
  163.  
  164. # close sexp
  165.  
  166.     print ")\n"
  167. }
  168.  
  169.  
  170. ### function print_common() {
  171. ### 
  172. ### # output common block name
  173. ### 
  174. ###     printf "(%s  ", toupper(cbname)
  175. ### 
  176. ### # output module
  177. ### 
  178. ###    if (MODULE != "")
  179. ###        printf "%s  ", MODULE
  180. ###    else
  181. ###        printf "*undefined*  "
  182. ###  
  183. ### 
  184. ### # output function type
  185. ### 
  186. ###     print "COMMON"
  187. ### 
  188. ### # parameters info
  189. ### 
  190. ###         printf ";;; Block elements:\n"
  191. ###     printf "  ("
  192. ### 
  193. ###     for (i = 1 ; i <= ncommons ; i++) {
  194. ###             print_arg(common[i])
  195. ###         }
  196. ###     print ")\n"
  197. ### 
  198. ### # callees
  199. ### 
  200. ###         printf ";;; Calls:\n"
  201. ###     printf "  ()\n"
  202. ### 
  203. ### # Local variables
  204. ### 
  205. ###     printf ";;; Local variables:\n"
  206. ###     printf "  ()\n"
  207. ###     
  208. ### # Include files
  209. ###     printf ";;; Includes:\n"
  210. ###     printf "  ()\n"
  211. ### 
  212. ### # Externals
  213. ###     printf ";;; Externals:\n"
  214. ###     printf "  ()\n"
  215. ### 
  216. ### # close sexp
  217. ### 
  218. ###     print ")\n"
  219. ### }
  220. ### 
  221.  
  222. function clear_globals () {
  223.     fcn_name = ""
  224. #  Clear out array of parameters names
  225.  
  226.     for (i in param_names) delete param_names[i]
  227.     for (i in param_nums) delete param_nums[i]
  228.  
  229. #   Clear out includes
  230.     for (i in includes) delete includes[i]
  231.     nincs = 0
  232.  
  233. #   Clear out externals
  234.     for (i in externals) delete externals[i]
  235.  
  236. #   Clear out locals
  237.     for (i in locals) delete locals[i]
  238.  
  239. #   Clear out common blocks
  240.    for (c in common) delete common[c]
  241.  
  242. #   Clear out constants
  243.    nconsts = 0
  244.    for (i in const_names) {
  245.       delete const_names[i]
  246.       delete const_vals[i]
  247.    }
  248.  
  249. }
  250.  
  251. BEGIN {
  252.    first_time = 1
  253.    IGNORECASE = 1
  254. }
  255.  
  256.  
  257. # parse function declaration line
  258. { if ($0 ~ /^      +SUBROUTINE/ ||
  259. $0 ~ /^      +REAL +FUNCTION/ ||
  260. $0 ~ /^      +REAL\*[0-9]+ +FUNCTION/ ||
  261. $0 ~ /^      +INTEGER +FUNCTION/ ||
  262. $0 ~ /^      +INTEGER\*[0-9]+ +FUNCTION/ ||
  263. $0 ~ /^      +LOGICAL +FUNCTION/ ||
  264. $0 ~ /^      +LOGICAL\*[0-9]+ +FUNCTION/ ||
  265. $0 ~ /^      +CHARACTER +FUNCTION/ ||
  266. $0 ~ /^      +CHARACTER\*[0-9]+ +FUNCTION/) {
  267.  
  268.  
  269. # if there already is a function parsed - flush collected info
  270.  
  271.     if (!first_time) {
  272.  
  273. # print rest of fn's info
  274.  
  275.         print_fcn()
  276.     }
  277.  
  278.     clear_globals()
  279.  
  280.     first_time = 0
  281.  
  282.     if ($0 ~ /^      +SUBROUTINE/) {
  283.     firstarg = 4
  284.     is_fn = 0
  285.     }
  286.     else {
  287.     firstarg = 5
  288.     is_fn = 1
  289.     }
  290.     
  291.     
  292. # parse function info to array
  293.  
  294.     nfargs = split($0, param_names, /[ ,\(\)]+/) - 1
  295.  
  296.     fcn_name = param_names[firstarg-1]
  297.  
  298.     if (is_fn)
  299.     fn_type = param_names[firstarg - 3]
  300.  
  301.  
  302. # compact array (remove all stuff except params names)
  303.  
  304.     for (i = firstarg; i <= nfargs; i++)
  305.     param_names[i - firstarg + 1] = toupper(param_names[i])
  306.  
  307.     for (i = nfargs - firstarg + 2 ; i <= nfargs ; i++)
  308.     delete param_names[i]
  309.  
  310.     nfargs -= firstarg - 1
  311.  
  312. # The above preserves the order of the parameters - important.
  313. # However, we also need to be able to check if variables are
  314. # parameters, so we also create the inverse array:
  315.     for (i in param_names) 
  316.        param_nums[param_names[i]] = i
  317. }
  318. # now parsing args declarations
  319. else if ($0 ~ /^      +REAL/ ||
  320. $0 ~ /^      +REAL\*[0-9]+/ ||
  321. $0 ~ /^      +INTEGER/ ||
  322. $0 ~ /^      +INTEGER\*[0-9]+/ ||
  323. $0 ~ /^      +LOGICAL/ ||
  324. $0 ~ /^      +LOGICAL\*[0-9]+/ ||
  325. $0 ~ /^      +CHARACTER/ ||
  326. $0 ~ /^      +CHARACTER\*[0-9]+/ ||
  327. $0 ~ /^      +%STRING%/ ) {
  328.  
  329.  
  330.     gsub(",", " , ", $0)
  331.     gsub(/\(/, " ( ", $0)
  332.     gsub(/\)/, " ) ", $0)
  333.     if ($0 ~ /^      +CHARACTER/) {
  334.        gsub(/\*/, " * ", $0)
  335.     }
  336.  
  337.     type = toupper($1)
  338.  
  339.     i = 2
  340.     decllen = ""
  341.     if ($i == "*") {
  342.       i++
  343.       if ($i == "(") {
  344.          i++
  345.          while (i <= NF && $i !~ /^\)$/) {
  346.             decllen = decllen $i
  347.             i++
  348.          }
  349.        }
  350.        else {
  351.          decllen = $i
  352.        }
  353.        i++
  354.     }
  355.  
  356.     while (i <= NF) {
  357.     pname = toupper($i)
  358.     gsub(",", " ", pname)
  359.     if (pname ~ /^ *$/) {
  360.         i++
  361.         }
  362.     else {
  363.  
  364.        i++
  365.  
  366.        stmpa = " "
  367.            stmpcharlen = decllen
  368.            ## Handle dimensions
  369.        if ($i ~ /^\($/) {
  370.            stmpa =  "(\042"
  371.                i++
  372.     
  373.            while (i <= NF && $i !~ /^\)$/) {
  374.                if ($i == ",") {
  375.                       stmpa = stmpa "\042 \042"
  376.                    }
  377.                    else {
  378.               stmpa = stmpa $i " "
  379.                    }
  380.            i++
  381.            }
  382.  
  383.            stmpa = stmpa "\042)"
  384.            i++
  385.        }
  386.            # Handle char vars otf foo*10, foo*(*), etc.
  387.            if ($i == "*") {
  388.           stmpcharlen = ""
  389.               i++
  390.               if ( $i == "(" ) {
  391.                  smtpcharlen = $i
  392.                  i++
  393.  
  394.              while (i <= NF && $i != ")") {
  395.                     stmpcharlen = stmpcharlen $i
  396.                     i++
  397.                  }
  398.                  i++
  399.               }
  400.               else {
  401.                  stmpcharlen = $i
  402.                  i++
  403.               }
  404.            }
  405.        if ( stmpcharlen != "" ) {
  406.               var_type[pname]  = type "*" stmpcharlen
  407.               var_dimen[pname] = stmpa
  408.            }
  409.            else {
  410.               var_type[pname]  = type
  411.               var_dimen[pname] = stmpa
  412.            }
  413.         }
  414.     }
  415. }
  416. }
  417.  
  418. # Include file parsing:
  419. /^      +INCLUDE/ {
  420.    nincs ++
  421.    inc = $2
  422.    gsub("'", "\042", inc)
  423.    includes[nincs] = inc
  424. }
  425.  
  426. # External stmt parsing
  427. /^      +EXTERNAL/ {
  428.    gsub(",", "", $0);
  429.    for (i=2; i <= NF; i++) {
  430.       externals[toupper($i)] = 1
  431.    }
  432. }
  433.  
  434. # Is this a program instead of a subroutine?
  435. /      +PROGRAM/ {
  436.    fcn_name = "MAIN"
  437. }
  438.  
  439. # Common block parsing:
  440. /      +COMMON/ {
  441.    gsub(/[,/]/, " ", $0);
  442.    cbname= toupper($2)
  443.    for (i=3; i <= NF; i++) {
  444.       common[cbname] = common[cbname] " " toupper($i)
  445.    }
  446. }
  447.  
  448. # Parameter parsing:
  449. /      +PARAMETER/ {
  450.    gsub(/[,=()]/, " & ", $0)
  451.    for (i=3; i<NF; i++) {
  452.       p = $i   # Get param name
  453.       pv = ""
  454.       for (i=(i+2); (i<NF && ($(i+2) != "=")); i++) {  # Collect param values
  455.          pv = pv $i
  456.       }
  457.       nconsts++
  458.       const_names[nconsts] = p
  459.       const_vals[nconsts]  = pv
  460.    }
  461. }
  462.  
  463. # if there are non-printed parameters - print them
  464.  
  465. END {
  466.  
  467.    print_fcn()
  468. }
  469.  
  470. # end of $Source: /usr/bfr/src/test/RCS/fts-f2si.awk,v $
  471.